The X-Philes (2nd Revision)/The X-Philes Number 1 (1995).iso/xphiles/hp48_1/simeq

Internet Message Format | 1995-03-31 | 7KB

From comp.sys.handhelds Tue Jun 18 12:48:15 1991
Path: seq!ecsgate!mcnc!taco!lll-winken!elroy.jpl.nasa.gov!sdd.hp.com!caen!news.cs.indiana.edu!noose.ecn.purdue.edu!en.ecn.purdue.edu!blair
From: [e-mail] (Marc E Blair)
Newsgroups: comp.sys.handhelds
Subject:  Solve Sim Eq with symbolics
Message-ID: <[e-mail]>
Date: 12 Jun 91 22:48:53 GMT
References: <[e-mail]>
Organization: Purdue University Engineering Computer Network
Lines: 348

This is a newer version which allows symbolics in solving simeq and also
simplifies answers further than the old program.

->Q   This program toggles fraction mode (a little block appears to indicate
      fraction mode) otherwise straight decimals will be used. Fractions can
      eat up memory on lengthy calculations.

det   returns a determinant of a matrix. It behaves much like the routine
      Eliel Louzouen wrote a while back, although I wrote this with speed
      as first priority. The approach I used resulted in a twelvefold
      increase in speed with numeric evaluation and a threefold increase in
      symbolic evaluation than the original routines.

simeq solves a system of equations in matrix format... i.e. 4x+5y=9 and
      3x+2y=10 would be entered { { 4 5 9 } { 3 2 10 } } and evaluated
      returning { '32/7' '-(13/7)' } meaning x=32/7 and y=-13/7.
      The program uses matrices to solve if there are less than five
      variables, >5 results in row reduction. (this way a ten variable
      equation takes 5 minutes, matrix methods would take 25 days)

rr    row reduction program to reduce matrices into row-echelon form.
      symbolic row reduction is supported.

inv   invert a matrix using row reduction techniques

mec   expand and collect and evaluate all items in a matrix to their most
      simple form
-----  All other variables are subprograms.

I am not repsonsible for memory loss, hardware trouble, loss of math abilities,
sudden shifts in the space-time continuum, or other problems which  might occur
due to the use of this program but in all likelihood will never happen .

enjoy!
----------------------->8--------->8---
%%HP: T(3)A(R)F(.);
DIR
  \->q
    \<<
      IF QR
      THEN '\->q\[]'
DUP RCL SWAP PURGE
'\->q' STO
      ELSE '\->q' DUP
RCL SWAP PURGE
'\->q\[]' STO
      END QR NOT
'QR' STO
    \>>
  Rr
    \<< Dec \-> L S
      \<< S L \161RR 0 1
S
        FOR A A L *
A - 2 + PICK +
        NEXT
        IF ZRO?
SWAP DROP NOT
        THEN S L
\161RR
        END 1 L
        FOR A S
\->LIST L A - S * A +
ROLLD
        NEXT L
\->LIST
      \>>
    \>>
  det
    \<< Dec DROP MNN
    \>>
  EC
    \<< EVAL
      DO DUP EXPAN
DUP ROT
      UNTIL SIZE
SWAP SIZE ==
      END
      DO DUP COLCT
DUP ROT
      UNTIL SIZE
SWAP SIZE ==
      END
    \>>
  SIMEQ
    \<< DUP Dec DUP
      IF 6 <
      THEN DUP2 1 -
        IF ==
        THEN DROP \->
Ss
          \<< 0 Ss
            FOR Aa
Ss DUP * Ss
              FOR
Bb Bb Aa + PICK Ss
NEG
              STEP
Ss \->LIST Ss Ss 1 +
* 1 + ROLLD
            NEXT Ss
Ss 1 + * DROPN Ss 1
+ ROLL \-> Cc
            \<< Ss
DUPN Ss \->LIST det \->
Dd
              \<<
IF Dd ZRO? SWAP
DROP NOT
THEN 1 Ss
  FOR Aa Ss DUPN Aa
ROLL DROP Cc Aa
ROLLD Ss \->LIST det
Dd /
    IF QR
    THEN \->Q
    END Ss 1 +
ROLLD
  NEXT Ss DROPN Ss
\->LIST
ELSE Ss DROPN
"No Solution"
END
              \>>
            \>>
          \>>
        ELSE *
DROPN
"BAD # OF EQS"
        END SWAP
DROP
      ELSE * DROPN
SM2
      END
    \>>
  inv
    \<< Dec \-> S L
      \<< 0 L 1 -
        FOR A 0 S 1
-
          FOR B A B
== L S * L - 1 + A
L * - ROLLD
          NEXT
        NEXT L S
      \>> DUP + \-> L S
      \<< S L \161RR 1 L
        FOR A S 2 /
\->LIST L A - S * A +
S 2 / + ROLLD S 2 /
DROPN
        NEXT L
\->LIST
      \>>
    \>>
  MEC
    \<< OBJ\-> \-> A
      \<< 1 A 1 -
        FOR B +
        NEXT OBJ\-> \->
S
        \<< 1 S
          FOR C EC
S ROLLD
          NEXT 1 A
          FOR D S A
/ \->LIST S S A / D *
- D + ROLLD
          NEXT A
\->LIST
        \>>
      \>>
    \>>
  SM2
    \<< Rr 0 'ER' STO
{ } SWAP OBJ\-> \-> S
      \<< 1 S
        FOR A OBJ\->
\-> L
          \<< L S A -
- ROLL
            IF 1 \=/
            THEN 1
'ER' STO
            END S A
- L + ROLL + S A -
L 1 - + ROLLD 0 1 L
2 -
            FOR C +
            NEXT
            IF 0 \=/
            THEN 1
'ER' STO
            END
          \>>
        NEXT
        IF ER 1 ==
        THEN DROP
"NO SOLUTION"
        END 'ER'
PURGE
      \>>
    \>>
  Dec
    \<< OBJ\-> DUP TYPE
      IF 5 ==
      THEN EVAL
      ELSE \-> L
        \<< 1 L 1 -
          FOR A +
          NEXT OBJ\->
L / L SWAP
        \>>
      END
    \>>
  ZRO?
    \<< DUP TYPE 0
      IF \=/
      THEN 0
      ELSE DUP
        IF 0 \=/
        THEN 0
        ELSE 1
        END
      END
    \>>
  \161RR
    \<< \-> L S
      \<< 0 S 1 -
        FOR A S L *
A - DUP 1 + PICK \->
F M1
          \<< 1 S 1 -
            FOR B F
B L * - DUP 1 +
PICK \-> C M2
              \<< M2
ZRO?
IF NOT
THEN DROP 0 L 1 -
  FOR D C A + D -
ROLL M1 0 'DOIT'
STO ZRO?
    IF NOT
    THEN *
    ELSE DROP 1
'DOIT' STO
    END F A + D -
PICK M2 ZRO?
    IF NOT
    THEN *
    ELSE DROP 1
'DOIT' STO
    END - EXPAN
COLCT C A + D -
ROLLD
  NEXT
ELSE DROP
END
              \>>
            NEXT 1
L
            FOR Q S
L * ROLL
            NEXT
          \>> 'DOIT'
PURGE
        NEXT 0 S 1
-
        FOR B L S B
- * B - PICK S B -
L * \-> D F
          \<< 0 L 1 -
            FOR C F
C - ROLL
              IF D
TYPE 0 ==
              THEN
IF D 0 ==
THEN \oo *
ELSE D / COLCT
  IF QR
  THEN \->Q
  END DUP TYPE 9 ==
OVER EVAL DUP IP ==
AND
  IF DUP TYPE 0 ==
  THEN
    IF
    THEN EVAL
    END
  ELSE DROP
  END
END
              ELSE
D / COLCT
              END F
C - ROLLD
            NEXT
          \>>
        NEXT
      \>>
    \>>
  MNN
    \<< \-> Ss
      \<<
        IF Ss 3 ==
        THEN 6 DUPN
6 DUPN ROT DROP 4
ROLL * 3 ROLLD * -
SWAP DROP 16 PICK *
16 ROLLD SWAP DROP
4 ROLL DROP 4 ROLL
* 3 ROLLD * - 9
PICK * 10 ROLLD
DROP ROT DROP 4
ROLL * 3 ROLLD * -
* ROT DROP SWAP
DROP SWAP - +
        ELSE
          IF Ss 2
==
          THEN 4
ROLL * 3 ROLLD * -
          ELSE 1 Ss
            FOR Aa
Ss DUP DUP * SWAP -
DUPN Ss DUP * Ss 2
* - 0
              FOR
Bb Bb Aa + ROLL
DROP Ss NEG
              STEP
Ss 1 - MNN Ss DUP *
Ss - Aa + 1 + PICK
* -1 Aa Ss + ^ * Ss
Ss * 1 + ROLLD
            NEXT Ss
Ss * DROPN 1 Ss 1 -
            FOR Aa
+
            NEXT
          END
        END
      \>>
    \>>
  QR 0
END